(in-package :cl-fast-ecs)

(declaim (type list *system-registry*))
(define-global-var *system-registry* nil)

(declaim (type list *system-order-constraints*))
(define-global-var *system-order-constraints* nil)

(declaim (type hash-table *system-bitmap-rebuilders*))
(define-global-var *system-bitmap-rebuilders* (make-hash-table :test #'eq))

(declaim (inline %unknown-system))
(defun %unknown-system (system)
  (error
   "System ~a not found. Known systems are: ~{~a~^, ~}" system
   (loop :for (name nil) :on *system-registry* :by #'cddr :collecting name)))

(declaim (inline %append-to-hash-table))
(defun %append-to-hash-table (table key val)
  (pushnew val (gethash key table nil)))

(defun %reorder-systems! (new-system after before)
  "Topologically sort systems according to their BEFORE and AFTER constraints
with respect to newly added system, using DFS."
  (let* ((new-system-name (make-keyword new-system))
         (count (1+ (hash-table-size *system-bitmap-rebuilders*)))
         (new-order-constraints (copy-list *system-order-constraints*))
         (_ (setf (getf new-order-constraints new-system-name)
                  (list after before)))
         (edges (loop :with edges := (make-hash-table :test 'eq :size count)
                      :for (system (after before))
                        :on new-order-constraints :by #'cddr
                      :do (dolist (a after)
                            (let ((after (make-keyword a)))
                              (unless (getf *system-registry* after)
                                (%unknown-system a))
                              (%append-to-hash-table edges system after)))
                          (dolist (b before)
                            (let ((before (make-keyword b)))
                              (unless (getf *system-registry* before)
                                (%unknown-system b))
                              (%append-to-hash-table edges before system)))
                      :finally (return edges)))
         (marks (make-hash-table :test 'eq :size count))
         (sorted nil))
    (declare (ignore _))
    (labels ((visit (node)
               (case (gethash node marks)
                 (:done nil)
                 (:in-progress (error "System dependency graph has a cycle"))
                 (otherwise
                  (setf (gethash node marks) :in-progress)
                  (dolist (dep (gethash node edges))
                    (visit dep))
                  (setf
                   (gethash node marks) :done
                   sorted (nconc sorted
                                 (list node (getf *system-registry* node))))))
               nil))
      (visit new-system-name)
      (loop :for (name nil) :on *system-registry* :by #'cddr :do (visit name))
      (setf *system-registry* sorted
            *system-order-constraints* new-order-constraints)
      nil)))

(declaim (ftype (function (simple-bit-vector simple-vector simple-vector)
                          (values simple-bit-vector fixnum fixnum))
                %rebuild-entities-bitmap)
         (notinline %rebuild-entities-bitmap))
(defun %rebuild-entities-bitmap (entities-bitmap component-indices
                                 component-no-indices)
  (let* ((entities-allocated *storage-entities-allocated*)
         (bitmap
           (if (/= (length entities-bitmap) entities-allocated)
               (make-array entities-allocated :element-type 'bit
                                              :initial-element 1)
               (fill entities-bitmap 1))))
    (loop :with component-storages := (storage-component-storages
                                       (the storage *storage*))
          :with min-entity :of-type fixnum := array-dimension-limit
          :with max-entity :of-type fixnum := -1
          :for component-index :of-type array-index :across component-indices
          :for component-storage :of-type component-soa
             := (svref component-storages component-index)
          :do (bit-and bitmap (component-soa-exists component-storage) t)
              (when (< (component-soa-min-entity component-storage) min-entity)
                (setf min-entity (component-soa-min-entity component-storage)))
              (when (> (component-soa-max-entity component-storage) max-entity)
                (setf max-entity (component-soa-max-entity component-storage)))
          :finally
             (loop :for component-index :of-type array-index
                   :across component-no-indices
                   :for component-storage :of-type component-soa
                      := (svref component-storages component-index)
                   :do (bit-andc2 bitmap
                                  (component-soa-exists component-storage) t))
             (return (values bitmap min-entity max-entity)))))

(defmacro defsystem (name (&key components-ro components-rw components-no
                                arguments initially finally (when t) (enable t)
                                with after before)
                     &body body)
  "Defines a system with a given `NAME` and component sets `COMPONENTS-RO` and
`COMPONENTS-RW` with read-only and read-write access to component slots,
respectively. `COMPONENTS-NO` defines a list of components that should not
appear on entities processed by the system. `ARGUMENTS` is a two-list of the
keyword arguments the system expects to be passed via `RUN-SYSTEMS`, just like
in `FTYPE` declaration.

Can be called from a top-level or embedded into other form. Allows
redefinition of system with the same `NAME` but different `BODY` or set of
components.

Note that requested components should be defined with `DEFCOMPONENT` before
defining the system.

The `BODY` of forms (with optional docstring) would be run for every entity
containing all of the components from the given set, having the following
bindings:

* `ENTITY` — the entity being processed;
* `ComponentName-SlotName` for every slot of every component specified.

The forms in `BODY` are enclosed in block named `CURRENT-ENTITY`, so the
processing could be skipped to the next entity by calling
`(RETURN-FROM CURRENT-ENTITY)`.

The `INITIALLY` form would be evaluated before the entities loop, and the
`FINALLY` form would be evaluated after the loop and its value would be
returned from the system.

The `WHEN` form is evaluated every entity loop iteration to check if that
entity should be processed or not.

The `ENABLE` form is evaluated before the entity loop to check if the entire
loop needs to run or not.

The `WITH` form, having lambda list `(VARS ＆KEY OF-TYPE =)`, allows to
initialize the local variables once before the loop starts. The `VARS` and
`OF-TYPE` could be the single symbol or the list, and in latter case the
required `=` argument should be mutliple values.

`BEFORE` and `AFTER` lists denote names of systems that need to be run before
and after the system being defined, respectively. If there are cycles in order
graph defined by those arguments, a corresponding error is thrown. When both
`BEFORE` and `AFTER` are `NIL`, the last defined system would be executed
first.

See also `RUN-SYSTEMS`, `DELETE-SYSTEM`."
  (declare (type list components-ro components-rw components-no arguments))
  (with-gensyms (component-storages entities-bitmap min-entity max-entity rest)
    (multiple-value-bind (loop-body declarations documentation)
        (parse-body body :documentation t)
      (let* ((components (append components-ro components-rw))
             (e1 (unless components
                   (error "No components specified for system ~a" name)))
             (e2 (loop :for c :in (append components components-no)
                       :unless (find (make-keyword c) *component-registry*
                                     :test #'eq)
                       :collect c :into undefined-components
                       :finally
                          (when undefined-components
                            (error
                             "Following components are undefined: ~{~a~^, ~}~%~
                              Known components are: ~{~a~^, ~}"
                             undefined-components
                             (loop :for (c nil) :on *component-registry*
                                   :by #'cddr :collect c)))))
             (system-keyword (make-keyword name))
             (entity-symbol (intern "ENTITY" *package*))
             (actual-func-name (symbolicate name :-system (gensym)))
             vars var-types var-value
             (d (when with
                  (destructuring-bind (v &key of-type =) with
                    (unless =
                      (error "Missing = clause in WITH argument"))
                    (setf vars (if (symbolp v) `(,v) v)
                          var-types (if (symbolp of-type) `(,of-type) of-type)
                          var-value =))))
             (inner-loop
               `(loop ,@(when initially
                          (list :initially initially))
                      :for ,entity-symbol :of-type entity
                      :from ,min-entity :to ,max-entity
                      :unless (zerop (sbit ,entities-bitmap ,entity-symbol))
                      :when ,when
                      :do (block current-entity
                            (locally ,@declarations ,@loop-body))
                          ,@(when finally
                              (list :finally finally))))
             (actual-body (reduce
                           (lambda (bindings name)
                             `(,(format-symbol/component
                                 name "%WITH-~a-SLOTS" name)
                               nil ,(find name components-ro :test #'eq)
                               ,component-storages ,entity-symbol ,bindings))
                           components
                           :initial-value inner-loop))
             (component-index-names
               (map 'list (lambda (n) (format-symbol :cl-fast-ecs
                                                "+~a-COMPONENT-INDEX+" n))
                    components))
             (component-no-index-names
               (map 'list (lambda (n) (format-symbol :cl-fast-ecs
                                                "+~a-COMPONENT-INDEX+" n))
                    components-no))
             (component-indices
               (sort (map 'simple-vector
                          #'symbol-value component-index-names) #'<))
             (component-no-indices
               (sort (map 'simple-vector
                          #'symbol-value component-no-index-names) #'<))
             (all-component-indices
               (sort (map 'simple-vector
                          #'symbol-value (append
                                          component-index-names
                                          component-no-index-names)) #'<)))
        (declare (ignore e1 e2 d))
        `(eval-when (:compile-toplevel :load-toplevel :execute)
           (%reorder-systems! ',name ',after ',before)
           (let ((,entities-bitmap (make-array 0 :element-type 'bit))
                 (,min-entity array-dimension-limit)
                 (,max-entity -1)
                 (pristine t))
             (declare (type simple-bit-vector ,entities-bitmap)
                      (type fixnum ,min-entity ,max-entity)
                      (type boolean pristine))
             (setf (gethash ,system-keyword *system-bitmap-rebuilders*)
                   (lambda (created-bits removed-bits)
                     (when (or
                            pristine
                            ,@(map 'list
                                   (lambda (i)
                                     `(or (plusp (sbit created-bits ,i))
                                          (plusp (sbit removed-bits ,i))))
                                   all-component-indices))
                       (multiple-value-setq (,entities-bitmap
                                             ,min-entity
                                             ,max-entity)
                         (%rebuild-entities-bitmap ,entities-bitmap
                                                   ,component-indices
                                                   ,component-no-indices))
                       (setf pristine nil))
                     nil))
             (flet ((,actual-func-name (&rest ,rest
                                        &key ,@(mapcar
                                                (compose 'ensure-symbol 'car)
                                                arguments)
                                        &allow-other-keys)
                      ,@(when documentation (list documentation))
                      (declare (ignore ,rest))
                      (let ((,component-storages
                              (storage-component-storages
                               (the storage *storage*))))
                        (multiple-value-bind ,vars ,var-value
                          ,(when-let (type-declarations
                                      (remove
                                       nil
                                       (mapcar (lambda (var type)
                                                 (when type
                                                   `(type ,type ,var)))
                                               vars var-types)))
                             `(declare ,@type-declarations))
                          (when ,enable
                            ,actual-body)))))
               (declare
                (ftype (function (&rest t &key ,@(mapcar (lambda (arg)
                                                           `(,(make-keyword
                                                               (first arg))
                                                             ,(second arg)))
                                                         arguments)
                                        &allow-other-keys))
                       ,actual-func-name))
               #+(or abcl ccl)
               ,(when documentation
                  `(setf (documentation #',actual-func-name 'function)
                         ,documentation))
               (setf (getf *system-registry* ,system-keyword)
                     #',actual-func-name))))))))

(defmacro define-system (name (&key components-ro components-rw components-no
                                    arguments initially finally
                                    (when t) (enable t) with after before)
                         &body body)
  "An alias for `DEFSYSTEM`."
  `(defsystem ,name (:components-ro ,components-ro :components-rw ,components-rw
                     :components-no ,components-no
                     :arguments ,arguments
                     :initially ,initially :finally ,finally
                     :when ,when :enable ,enable :with ,with
                     :after ,after :before ,before)
     ,@body))

(declaim (ftype (function ((or symbol string)) (or null function))
                system-ref))
(defun system-ref (name)
  "Returns a system function object with given `NAME` (either
string, symbol or keyword); returns `NIL` if there's no system with such name."
  (getf *system-registry* (make-keyword name)))

(declaim (ftype (function ((or symbol string))) delete-system))
(defun delete-system (name)
  "Deletes system identified by `NAME` (either string, symbol or keyword) that
was previously defined with `DEFSYSTEM`. Throws an error if there's no system
with given name."
  (let ((system-name (make-keyword name)))
    (unless (remf *system-registry* system-name)
      (%unknown-system name))
    (remhash system-name *system-bitmap-rebuilders*)))

;; TODO defining new component while systems are running -> error about array lenghts!
(defun run-systems (&rest arguments)
  "Runs all of the systems registered with `DEFSYSTEM` with given optional
keyword `ARGUMENTS`.

NOTE: creating or removing components between calls to `RUN-SYSTEMS` incurs
small performance penalty on all affected systems because of recalculation of
set of entities the system should process."
  (with-storage ()
    (let ((initial-created-bits (make-array *component-registry-length*
                                            :element-type 'bit))
          (initial-removed-bits (make-array *component-registry-length*
                                            :element-type 'bit)))
      (declare (type simple-bit-vector
                     initial-created-bits initial-removed-bits)
               (dynamic-extent initial-created-bits initial-removed-bits))
      (replace initial-created-bits (storage-component-created-bits storage))
      (replace initial-removed-bits (storage-component-removed-bits storage))
      (fill (storage-component-created-bits storage) 0)
      (fill (storage-component-removed-bits storage) 0)
      (loop :for (system-name system) :on *system-registry* :by #'cddr
            :for rebuilder := (gethash system-name *system-bitmap-rebuilders*)
            :do (when (> *component-registry-length*
                         (length initial-created-bits))
                  (adjust-simple-arrayf initial-created-bits
                                        *component-registry-length*
                                        :element-type 'bit :initial-element 0)
                  (adjust-simple-arrayf initial-removed-bits
                                        *component-registry-length*
                                        :element-type 'bit :initial-element 0))
                (bit-ior initial-created-bits
                         (storage-component-created-bits storage) t)
                (bit-ior initial-removed-bits
                         (storage-component-removed-bits storage) t)
                (funcall (the function rebuilder)
                         initial-created-bits
                         initial-removed-bits)
                (apply (the function system) arguments)))))
